home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / ada / adaed-1.11 / adaed-1 / Adaed-1.11.0a / 13.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-07  |  30.0 KB  |  1,104 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #ifndef SEM
  11. #define SEM    1
  12. #endif
  13.  
  14. #include "hdr.h"
  15. #include "vars.h"
  16. #include "attr.h"
  17. #include "setprots.h"
  18. #include "dclmapprots.h"
  19. #include "arithprots.h"
  20. #include "errmsgprots.h"
  21. #include "miscprots.h"
  22. #include "smiscprots.h"
  23. #include "chapprots.h"
  24.  
  25.  
  26. /* 13. Representation Clauses*/
  27.  
  28. #define max_val(x,y)    ((x) > (y) ? (x) : (y)) 
  29.  
  30. #define rc_unset                 0    
  31. #define rc_set                    1
  32. #define rc_default                (-1)
  33.  
  34. #define storage_unit             32
  35. #define padding                  0
  36.  
  37. #define size_position            2
  38. #define storage_size_position    4
  39. #define small_position           4
  40. #define pack_position            4
  41. #define literal_map_position     4
  42. #define alignment_position       6
  43.  
  44. /*
  45.  * Currently the representation information is structured as follows:
  46.  *
  47.  * integer & floating point types
  48.  * [size]
  49.  *
  50.  * task & access types
  51.  * [size, storage_size]
  52.  *
  53.  * fixed point types
  54.  * [size] -- small is kept in the symbol table as 5th entry of signature
  55.  *
  56.  * array types
  57.  * [size, pack]
  58.  *
  59.  * record types
  60.  * [size, pack, [modulus, [[field, pos, first_bit, last_bit],...]]]
  61.  *
  62.  * enumeration types
  63.  * [size, literal_map]
  64.  *
  65.  */
  66.  
  67. static char *default_representation(Symbol, int);
  68. static void apply_length_clause(int, Symbol, Node);
  69. static void apply_enum_clause(Symbol, Tuple);
  70. static void apply_record_clause(Symbol, int, Tuple);
  71. static Tuple not_chosen_get(Symbol);
  72. static void not_chosen_delete(Symbol);
  73. static int default_size_value(Symbol);
  74. static int component_size(Symbol);
  75. static Tuple default_record_value(Symbol);
  76. extern int ADA_MAX_INTEGER;
  77.  
  78. void initialize_representation_info(Symbol type_name, int tag)
  79. /*;initialize_representation_info */
  80.  
  81. {
  82. /*
  83.  * Initialize the representation information of the given type by setting
  84.  * all its fields to the status unset. 
  85.  */
  86. Tuple    rctup;
  87. if (tag == TAG_RECORD) {
  88.    rctup = tup_new(7);
  89.    rctup[1] = (char *) tag;
  90.    rctup[2] = (char *) rc_unset;
  91.    rctup[4] = (char *) rc_unset;
  92.    rctup[6] = (char *) rc_unset;
  93. }
  94. else if (tag == TAG_TASK    || tag == TAG_ACCESS    ||
  95.          tag == TAG_ARRAY    || tag == TAG_ENUM) {
  96.    rctup = tup_new(5);
  97.    rctup[1] = (char *) tag;
  98.    rctup[2] = (char *) rc_unset;
  99.    rctup[4] = (char *) rc_unset;
  100. }
  101. else {            /*  TAG_INT  || TAG_FIXED */
  102.    rctup = tup_new(3);
  103.    rctup[1] = (char *) tag;
  104.    rctup[2] = (char *) rc_unset;
  105. }
  106. RCINFO(type_name) = rctup;
  107. FORCED(type_name) = FALSE;
  108. not_chosen_put(type_name, (Symbol)0);
  109. }
  110.  
  111. void choose_representation(Symbol type_name)
  112. /*;choose_representation(type_name)*/
  113. {
  114. Symbol    b_type;
  115. Tuple    current_rep;
  116. Tuple    tup;
  117. int        status,i,n;
  118.  
  119. b_type = base_type(type_name);
  120. current_rep = RCINFO(b_type);
  121.  
  122. if (current_rep == (Tuple)0) {
  123.    REPR(type_name) = (Tuple)0;
  124.    return;
  125. }
  126. n = tup_size(current_rep);
  127. for (i=2; i<=n; i+=2) { 
  128.    status = (int) current_rep[i];
  129.    if (status == rc_unset) {
  130.       current_rep[i] = (char *) rc_default;
  131.       current_rep[i+1] = (char *) default_representation(type_name,i);
  132.    }
  133. }
  134. tup = tup_new((n/2)+1);
  135. tup[1] = current_rep[1];
  136. for (i=1; i<=(n/2); i++) { 
  137.   tup[i+1] = current_rep[2*i+1];
  138. }
  139. REPR(type_name) = tup;
  140. }
  141.  
  142. void inherit_representation_info(Symbol derived_type, Symbol parent_type)
  143. /*; inherit_representation_info */
  144. {
  145. Symbol    b_type;
  146. Symbol    v_type;
  147. Tuple    current_rep;
  148. int        i,n;
  149.  
  150. /*
  151.  * A derived type inherits all the representation information of its parent.
  152.  * However, this information is only considered to have a status of a 'default'
  153.  * representation which may be overidden by an explicit representation clause
  154.  * given to the derived type. It is therefore necessary to change the status
  155.  * field of the derived type when the parent had the status of 'set'.
  156.  */
  157.  
  158. /*
  159.  * If the parent type is private we must retrieve its base type from the
  160.  * private_decls entry
  161.  */
  162.    if (TYPE_OF(parent_type) == symbol_private ||   
  163.        TYPE_OF(parent_type) == symbol_limited_private) {
  164.        v_type = private_decls_get((Private_declarations)
  165.                       private_decls(SCOPE_OF(parent_type)), parent_type);
  166.         /*
  167.          * Check to seem if vis_decl is defined before accessing it. It might be
  168.          * undefined in the case of compilation errors.
  169.          */
  170.          if (v_type != (Symbol)0) {
  171.              b_type = TYPE_OF(v_type);     /* TYPE_OF field in the symbol table */
  172.          }
  173.          else {
  174.            return;
  175.          }
  176.     }
  177.     else  {
  178.            b_type = base_type(parent_type);
  179.     }
  180.     current_rep = RCINFO(b_type);
  181.     if (current_rep == (Tuple)0) {
  182.         return;
  183.     }
  184.     current_rep = tup_copy((Tuple)RCINFO(b_type));
  185.     n = tup_size(current_rep);
  186.     for (i=2;i<=n;i+=2) {
  187.           if ((int)current_rep[i] == rc_set) {
  188.               current_rep[i] = (char *) rc_default;
  189.         }
  190.         else if ((int) current_rep[i] == rc_unset) {
  191.               current_rep[i] = (char *) rc_default;
  192.             current_rep[i+1] = (char *) default_representation(derived_type,i);
  193.            }
  194.      }
  195.     RCINFO(derived_type) = current_rep;
  196.     FORCED(derived_type) = FALSE;
  197.     not_chosen_put(derived_type, (Symbol)0);
  198. }
  199. already_forced(Symbol type_name)                 /*; already_forced */
  200. {
  201. int    result;
  202. result = FORCED(type_name);
  203. return result;
  204. }
  205.  
  206. void force_representation(Symbol type_name)         /*; force_representation */
  207. {
  208. Symbol     b_type,r_type,v_type,sym;
  209. Fortup    ft1;    
  210. Tuple    current_rep,tup,field_names;
  211. int        i,n;
  212.  
  213. b_type = base_type(type_name);
  214.  
  215. /* Check if type has already been forced. */
  216. if (already_forced(b_type)) {
  217.    return;
  218. }
  219. else {
  220.    if (is_generic_type(b_type)) {
  221.   /*
  222.    * There is no need to force a generic formal type since any use of this
  223.    * type will refer to the generic actual parameter after the instantiation
  224.    * and therefore the representation information is just that of the actual.
  225.    * Subtypes of generic formal types will be handled differently with the
  226.    * 'delayed_repr' instruction generated in Subtype_Declaration.
  227.    */
  228.       not_chosen_delete(b_type);
  229.       return;
  230.    }
  231. #ifdef TBSL
  232.    else if (has_generic_component(b_type)) {
  233.    /* If a type has generic components its forcing must be delayed until
  234.     * the point of instantiation when the representation of the actuals are
  235.     * known, since the representation of the record or array is dependent on
  236.     * the representation of the generic components. The replace routine will
  237.     * choose the representation for all
  238.     * delayed reprs.
  239.     */
  240.       delayed_reprs with:= b_type;
  241.       FORCED(b_type) = TRUE;
  242.       return;
  243.    }
  244. #endif
  245.    FORCED(b_type) = TRUE;
  246.    current_rep = RCINFO(b_type);
  247.    if (current_rep == (Tuple)0) {
  248.       /* some sort of error condition */
  249.       not_chosen_delete(b_type);
  250.       return;
  251.    }
  252.    n = tup_size(current_rep);
  253.    for (i=2;i<=n;i+=2) {
  254.      if ((int)current_rep[i] == rc_default) {
  255.         current_rep[i] = (char *) rc_set;
  256.      }
  257.    }
  258.    RCINFO(b_type) = current_rep;
  259.   /*
  260.    * Force all component fields of the record type before the representation is
  261.    * decided for the record type since the component types may affect the size
  262.    * of the record.
  263.    */
  264.  
  265.    if (is_record(b_type)) {
  266.       r_type = root_type(type_name);
  267.       if (TYPE_OF(r_type) == symbol_private ||
  268.           TYPE_OF(r_type) == symbol_limited_private) {
  269.           v_type = private_decls_get((Private_declarations)
  270.                          private_decls(SCOPE_OF(r_type)), r_type);
  271.           if (v_type == (Symbol)0) {         /* error condition */
  272.               not_chosen_delete(b_type);
  273.               return;
  274.           }
  275.           field_names = build_comp_names((Node) invariant_part(v_type));
  276.       }
  277.       else {
  278.           field_names = build_comp_names((Node) invariant_part(b_type));
  279.       }
  280.       FORTUP(sym=(Symbol),field_names,ft1);
  281.          force_representation(TYPE_OF(sym));
  282.       ENDFORTUP(ft1);
  283.    }
  284.    choose_representation(b_type);
  285.    tup = not_chosen_get(b_type);
  286.    FORTUP(sym=(Symbol),tup, ft1);
  287.      choose_representation(sym);
  288.    ENDFORTUP(ft1);
  289.    not_chosen_delete(b_type);
  290. }
  291. }
  292. void force_all_types()                                 /*; force_all_types */
  293. {
  294. Symbol    b_type;
  295.  
  296. /*
  297.  * Called at the end of a declarative part, to force all types not already
  298.  * affected by a forcing occurence.
  299.  */
  300.  
  301. while (tup_size(NOT_CHOSEN) > 0) {
  302.    b_type = (Symbol) NOT_CHOSEN[1];
  303.    force_representation(b_type);
  304. }
  305. }
  306. char *default_representation(Symbol type_name,int position)
  307. /*;default_representation */
  308. {
  309.    switch (position) {
  310.       case(size_position):
  311.        return (char *) default_size_value(type_name);
  312.  
  313.       case(storage_size_position):
  314.           if (is_task_type(type_name) || is_access(type_name)) {
  315.              return (char *) OPT_NODE;
  316. #ifdef TBSL
  317.               return (char *) new_ivalue_node(int_const(ADA_MAX_INTEGER), 
  318.                              symbol_integer);
  319. #endif
  320.           }
  321.           else if (is_fixed_type(type_name)) {
  322.               return (char *) default_size_value(type_name);
  323.           }
  324.           else if (is_array(type_name)) {
  325.           /* (pack_position) */
  326.            return (char *) FALSE;
  327.           }
  328.           else if (NATURE(type_name) == na_enum)  {
  329.            /*(literal_map_position) */
  330.            return (char *) literal_map(type_name);
  331.           }
  332.           break;
  333.  
  334.        case(alignment_position):
  335.          return (char *) default_record_value(type_name);
  336.    }
  337. }
  338.  
  339. /*
  340.  * Changes:
  341.  * 7/10/86     ACD     
  342.  *  Allowed a 'small' field be processed for fixed-point numbers.  This
  343.  *  entailed enabling the function 'length_clause' to process smalls.
  344.  *  Only 'smalls' which are a power of 10 or 2 are allowed (this is
  345.  *  checked in the routine 'make_fixed_template' in type.c in code generator.
  346.  *  Note that all other length specifications are still disabled
  347.  *
  348.  *  In addition, the processing of 'SMALL' the call to 'check_type' was     
  349.  *  modified to "check_type_r(expn)" instead of "check_type(attr_prefix, expn)"
  350.  *  This is how it was done in the SETL system.
  351.  */
  352. void length_clause(Node node)                    /*;length_clause*/
  353. {
  354.     Node    attr_node,expn,a_node,arg1;
  355.     int        attr_kind,nk;
  356.     Symbol    b_type,attr_prefix;
  357.     Tuple    tsig;
  358.  
  359. /*
  360.  *  This procedure processes a length clause.  
  361.  *  It first performs semantic actions on the length clause and the expression
  362.  *  associated with the clause and initializes variables.  If the clause is
  363.  *  a SMALL clause, then it checks that the prefix is a type with fixed
  364.  *  root type.  If so, then it checks that the expression is an ivalue.
  365.  *  If it passes both of these checks then the value of the small is added
  366.  *  to the type constraint.
  367.  */
  368.      attr_node = N_AST1(node);
  369.      expn      = N_AST2(node);
  370.      adasem(attr_node);
  371.      adasem(expn);
  372.      a_node = N_AST1(attr_node);
  373.      arg1 = N_AST2(attr_node);
  374.      attr_kind = (int) attribute_kind(attr_node);
  375.      find_old(arg1);
  376.      attr_prefix = N_UNQ(arg1);
  377.  
  378. if (attr_kind == ATTR_SIZE) {
  379.    if (is_type(attr_prefix)) {
  380.       check_type (symbol_integer, expn);
  381.      if (is_static_expr(expn)) {
  382.        apply_length_clause(attr_kind, attr_prefix, expn);
  383.      }
  384.      else {
  385. #ifdef ERRNUM
  386.      errmsgn(105,106,expn);
  387. #else
  388.      errmsg("Expression in size spec is not static","13.2",expn);
  389. #endif
  390.      }
  391.    }
  392.    else {
  393. #ifdef ERRNUM
  394.       errmsgn(107,106,expn);
  395. #else
  396.       errmsg("Prefix of attribute is not type or first named subtype", "13.2", expn);
  397. #endif
  398.    }
  399. }
  400.      if (attr_kind == ATTR_SMALL) {
  401.         if (!is_type(attr_prefix) || root_type(attr_prefix) != symbol_dfixed) { 
  402. #ifdef ERRNUM
  403.         errmsgn(109,110,arg1);
  404. #else
  405.         errmsg("expect fixed type in representation clause for SMALL",
  406.                    "13.2(11)", arg1) ;
  407. #endif
  408.             return ;
  409.  
  410.         }  
  411.         else {
  412.          check_type_r(expn) ;
  413.              nk = N_KIND(expn);
  414.          if (nk!=as_ivalue && nk!=as_int_literal && nk!=as_real_literal) { 
  415. /*  The expression is not static.  Do not have to check whether it is a real */
  416. /*  or not, if it is not then an error was already emitted by check_type_r   */
  417. #ifdef ERRNUM
  418.              errmsgn(111,110,expn);
  419. #else
  420.              errmsg("expression for SMALL must be static","13.2(11)",expn);
  421. #endif
  422.              return ;
  423.          }   
  424.          else {
  425.                  b_type = TYPE_OF(attr_prefix);
  426.              tsig = SIGNATURE(b_type);
  427.              tsig[5] = (char *) expn;
  428.          }
  429.      }
  430. }
  431. else if (attr_kind == ATTR_STORAGE_SIZE) {
  432.    if (is_task_type(attr_prefix) || 
  433.        is_anonymous_task(attr_prefix) || 
  434.        is_access(attr_prefix)) {
  435.       check_type (symbol_integer, expn);
  436.       apply_length_clause(attr_kind, attr_prefix, expn);
  437.    }
  438.    else {
  439. #ifdef ERRNUM
  440.       errmsgn(108,106,expn);
  441. #else
  442.       errmsg("Prefix of attribute is not task type or access type", "13.2", expn);
  443. #endif
  444.    }
  445. }
  446.  
  447. else if (attr_kind == ATTR_SMALL) { 
  448.     if (!is_type(attr_prefix) || root_type(attr_prefix) != symbol_dfixed) { 
  449. #ifdef ERRNUM
  450.     errmsgn(109,110,arg1);
  451. #else
  452.     errmsg("expect fixed type in representation clause for SMALL", "13.2(11)", arg1) ;
  453. #endif
  454.     return ;
  455.     }
  456.     else {
  457.     check_type(attr_prefix, expn) ;
  458.     if (N_KIND(expn) != as_ivalue) { 
  459. #ifdef ERRNUM
  460.      errmsgn(111,110,expn);
  461. #else
  462.      errmsg("expression for SMALL must be static","13.2(11)",expn);
  463. #endif
  464.      return ;
  465.     }
  466.     else {
  467.         /* specified value of small is added to the type constraint. */
  468.         b_type = TYPE_OF(attr_prefix);
  469.         tsig = SIGNATURE(b_type);
  470.         tsig[5] = (char *) expn;
  471.     }
  472.     }
  473. }
  474. }
  475. static void apply_length_clause(int attr_kind, Symbol type_name, Node value)
  476. /*;apply_length_clause */
  477. {
  478.     Symbol b_type;
  479.     Tuple    current_rep;
  480.  
  481.     b_type = base_type(type_name);
  482.     current_rep = RCINFO(b_type);
  483.    if (attr_kind == ATTR_SIZE) {
  484.       current_rep[size_position] = (char *) rc_set;
  485.       current_rep[size_position+1] = (char *) INTV((Const) N_VAL(value));
  486.    }
  487.    else if (attr_kind == ATTR_STORAGE_SIZE) { 
  488.       current_rep[storage_size_position] = (char *) rc_set;
  489.       current_rep[storage_size_position+1] = (char *) value;
  490.    }
  491.    else { /* SMALL */
  492.    }
  493. }
  494. void enum_rep_clause(Node node)                            /*;enum_rep_clause*/
  495. {
  496.  
  497. Node    name_node,aggr_node,def_node;
  498. Node    indx_node,index_list_node,type_indic_node;
  499. Node    aggr_list_node;
  500. Symbol    type_name,enum_aggr_type;
  501. Tuple    old_lit_map,rep_lit_map,seq,tup;
  502. int        i,n; 
  503.  
  504. /* This procedure checks the validity of the representation clause for
  505.  * enumeration types. 
  506.  */
  507.  name_node = N_AST1(node); 
  508.  aggr_node = N_AST2(node);
  509.  find_old(name_node);
  510.  type_name = N_UNQ(name_node);
  511.  if (NATURE(root_type(type_name)) != na_enum) {
  512. #ifdef ERRNUM
  513.     errmsgn(112, 113, name_node);
  514. #else
  515.     errmsg("Identifier is not an enumeration type", "13.3", name_node);
  516. #endif
  517.     return;
  518.   }
  519.  
  520. /*
  521.  * The representation is given by a aggregate, whose index type is the
  522.  * given  enumeration  type,  and whose component  type is integer. We
  523.  * build such an array type for type checking, but emit no code for it.
  524.  */
  525.     enum_aggr_type = find_new(newat_str());
  526.     index_list_node = node_new(as_list);
  527.     indx_node = node_new(as_simple_name);
  528.     N_UNQ(indx_node) = type_name;
  529.     N_LIST(index_list_node) = tup_new1((char *)indx_node);
  530.     type_indic_node = node_new(as_simple_name);
  531.     N_UNQ(type_indic_node) = symbol_integer;
  532.     def_node = node_new(as_array_type);
  533.     N_AST1(def_node) = index_list_node;
  534.     N_AST2(def_node) = type_indic_node;
  535.     
  536.     new_constrained_array(enum_aggr_type, def_node);
  537.     tup = (Tuple) newtypes[tup_size(newtypes)];
  538.     tup_frome(tup);
  539.     
  540.     adasem (aggr_node);
  541.     check_type (enum_aggr_type, aggr_node);
  542.     /*if (is_static_expr(aggr_node)) {*/
  543.     if (1) {
  544.       aggr_list_node = N_AST1(aggr_node);
  545.       seq = N_LIST(N_AST1(aggr_list_node));
  546.       n = tup_size(seq);
  547.       for (i=1;i<n;i++) {
  548.          if (const_ge((Const)N_VAL((Node)seq[i]),
  549.                       (Const)N_VAL((Node)seq[i+1]))) {
  550. #ifdef ERRNUM
  551.         l_errmsgn(114, 115, 113, aggr_node);
  552. #else
  553.         errmsg_l("Integer code is not distinct or violates ",
  554.                "predefined ordering relation of type","13.3",aggr_node);
  555. #endif
  556.         return;
  557.          }
  558.       }
  559.         old_lit_map = (Tuple) OVERLOADS(type_name);
  560.         rep_lit_map = tup_new(n * 2);
  561.         for (i=1;i<=n;i++) {
  562.              rep_lit_map[2*i-1] = strjoin(old_lit_map[2*i-1], "");;
  563.              rep_lit_map[2*i] = (char *)  INTV((Const)N_VAL((Node)seq[i]));
  564.       }
  565.           apply_enum_clause(type_name, rep_lit_map);
  566.       }
  567.         else {
  568.          errmsg_l("Component of aggregate in enumeration representation clause",
  569.                   "is not static","13.3",aggr_node);
  570.          return ;
  571.     }
  572. }
  573. static void apply_enum_clause(Symbol type_name, Tuple rep_lit_map) 
  574. /*;apply_enum_clause*/
  575. {
  576. Symbol    b_type;
  577. Tuple    current_rep;
  578.  
  579. b_type = base_type(type_name);
  580. current_rep = (Tuple) RCINFO(b_type);
  581. if (current_rep == (Tuple)0) {
  582.   initialize_representation_info(b_type, TAG_ENUM);
  583.   current_rep = (Tuple) RCINFO(b_type);
  584. }
  585. current_rep[literal_map_position] = (char *) rc_set;
  586. current_rep[literal_map_position+1] = (char *) rep_lit_map;
  587. }
  588.  
  589. void rec_rep_clause(Node node)                 /*;rec_rep_clause */
  590.  
  591. {
  592. int        repr_err;
  593. int        modulus_value;
  594. Node    name_node;
  595. Symbol    type_name,comp;
  596. Node    align_clause,comp_clause_list;
  597. char    *field;
  598. Tuple    field_names,location_lists, duplic_list, loc_list;
  599. Node    comp_clause, rel_addr, bit_range,first_bit, last_bit;
  600. int        rel_addr_val;
  601. Fortup    ft1;
  602. Fordeclared    fd;
  603.  
  604. name_node = N_AST1(node);
  605. align_clause = N_AST2(node);
  606. comp_clause_list = N_AST3(node);
  607.  
  608. adasem(align_clause);
  609. sem_list(comp_clause_list);
  610. find_old(name_node);
  611. type_name = N_UNQ(name_node);
  612.  
  613. if (!is_record(type_name)) {
  614. #ifdef ERRNUM
  615.    errmsgn(118,119,name_node);
  616. #else
  617.    errmsg("Identifier is not a record type", "13.4", name_node);
  618. #endif
  619.    return ;
  620. }
  621.  
  622. repr_err = FALSE;
  623. if (align_clause == OPT_NODE) {
  624.   modulus_value = 0;
  625. }
  626. else {
  627.   check_type(symbol_integer, align_clause);
  628.   if (is_static_expr(align_clause)) {
  629.      modulus_value = INTV((Const)N_VAL(align_clause));
  630.   }
  631.   else {
  632. #ifdef ERRNUM
  633.      errmsgn(120,119,align_clause);
  634. #else
  635.      errmsg("Alignment clause must contain a static expression", "13.4", align_clause);
  636. #endif
  637.      repr_err = TRUE;
  638.    }
  639. }
  640. location_lists = tup_new(0);
  641. field_names = tup_new(0);
  642. FORDECLARED(field,comp,(Declaredmap)declared_components(base_type(type_name)),fd)
  643.    field_names = tup_with(field_names,field);
  644. ENDFORDECLARED(fd)
  645.  
  646. duplic_list = tup_new(0);
  647.  
  648. FORTUP(comp_clause=(Node), N_LIST(comp_clause_list), ft1)
  649.   field = N_VAL(N_AST1(comp_clause)); 
  650.   rel_addr = N_AST2(comp_clause);
  651.   bit_range = N_AST3(comp_clause); /* range node */
  652.    
  653.    if (!tup_memstr(field, field_names)) {
  654.     /* must verify what field in following errmsg calls (gs sep 20) */
  655. #ifdef ERRNUM
  656.       str_errmsgn(121,field,10,(Node)0);
  657. #else
  658.       errmsg_str("Component % does not appear in record type", field, "none",(Node)0);
  659. #endif
  660.       repr_err = TRUE;
  661.    }
  662.    else if (tup_memstr(field,duplic_list)) {
  663. #ifdef ERRNUM
  664.       str_errmsgn(122,field,10,(Node)0);
  665. #else
  666.       errmsg_str("Component % already occurs in clause", field,"none",(Node)0);
  667. #endif
  668.       repr_err = TRUE;
  669.    }
  670.    else {
  671.       duplic_list = tup_with(duplic_list,field);
  672.    }
  673.  
  674.    check_type (symbol_integer, rel_addr);
  675.    if (is_static_expr (rel_addr)) {
  676.       rel_addr_val = INTV((Const) N_VAL(rel_addr));
  677.    }
  678.    else {
  679. #ifdef ERRNUM
  680.       str_errmsgn(123,field,119,rel_addr);
  681. #else
  682.       errmsg_str("Expression for component % must be static", field,"13.4", rel_addr);
  683. #endif
  684.       repr_err = TRUE;
  685.    }
  686.    
  687.    if (N_KIND(bit_range) == as_range) {
  688.       first_bit = N_AST1(bit_range);
  689.       last_bit = N_AST2(bit_range);
  690.       check_type (symbol_integer, first_bit);
  691.       check_type (symbol_integer, last_bit);
  692.       if (is_static_expr(first_bit) && is_static_expr(last_bit)) {
  693.      loc_list = tup_new(4);
  694.      loc_list[1] = field;
  695.      loc_list[2] = (char *) rel_addr_val;
  696.      loc_list[3] = (char *) INTV((Const) N_VAL(first_bit));
  697.      loc_list[4] = (char *) INTV((Const) N_VAL(last_bit));
  698.      location_lists = tup_with(location_lists, (char *)loc_list);
  699.        }
  700.        else  {
  701. #ifdef ERRNUM
  702.      str_errmsgn(124,field,119,(Node)0);
  703. #else
  704.      errmsg_str("Range for component % must be static",field, "13.4",(Node)0);
  705. #endif
  706.      repr_err = TRUE;
  707.        }
  708.    }
  709. ENDFORTUP(ft1)
  710.  
  711.   if (repr_err) {
  712.      return;
  713.   }
  714.   else {
  715.      apply_record_clause(type_name, modulus_value, location_lists);
  716.   }
  717. }
  718. static void apply_record_clause(Symbol type_name, 
  719.                                 int modulus_value, Tuple location_lists)
  720. /*;apply_record_clause*/
  721.  
  722. {
  723.     Symbol    b_type;
  724.     char    *field;
  725.     Tuple    current_rep,attribute_list,tup,tup2,tup4;
  726.     int        offset,position,first_bit,start_bit,end_bit;
  727.     int        start_unit,field_size,record_size;
  728.     Fortup    ft1;
  729.     Declaredmap    decls;
  730.  
  731.     b_type = base_type(type_name);
  732.     current_rep = RCINFO(b_type);
  733.     record_size = 0;
  734.     attribute_list = tup_new(0);
  735.     decls = (Declaredmap) declared_components(b_type);
  736.  
  737.    FORTUP(tup=(Tuple),location_lists,ft1);
  738.       field = tup[1];
  739.       start_unit = (int) tup[2];
  740.       start_bit = (int) tup[3];
  741.       end_bit = (int) tup[4];
  742.       offset = storage_unit * start_unit + start_bit;
  743.       position = offset / storage_unit;
  744.       first_bit = offset % storage_unit;
  745.       field_size = end_bit - start_bit + 1;
  746.       record_size = max_val(record_size, (offset + field_size));
  747.       tup4 = tup_new(4);
  748.       tup4[1] = (char *) dcl_get(decls, field);
  749.       tup4[2] = (char *) position;
  750.       tup4[3] = (char *) first_bit;
  751.       tup4[4] = (char *) (first_bit + field_size -1);;
  752.       attribute_list = tup_with(attribute_list, (char *) tup4);
  753.    ENDFORTUP(ft1);
  754.    tup2 = tup_new(2);
  755.    tup2[1] = (char *) modulus_value;
  756.    tup2[2] = (char *) attribute_list;
  757.    current_rep[alignment_position] = (char *) rc_set;
  758.    current_rep[alignment_position+1] = (char *) tup2;
  759.    current_rep[size_position] = (char *) rc_set;
  760.    current_rep[size_position+1] = (char *) record_size;
  761.    RCINFO(b_type) = current_rep;
  762. }
  763.  
  764. static Tuple not_chosen_get(Symbol sym)                        /*;not_chosen_get*/
  765. {
  766.     int     i,n;
  767.  
  768. n = tup_size(NOT_CHOSEN);
  769. for (i=1;i<=n; i+=2) {
  770.     if ((Symbol) NOT_CHOSEN[i]== sym) {
  771.     return (Tuple) NOT_CHOSEN[i+1];
  772.     }
  773. }
  774. return tup_new(0);
  775. }
  776. void not_chosen_put(Symbol sym1, Symbol sym2)        /*;not_chosen_put*/
  777. {
  778.     Tuple    tup;
  779.     int     i,n;
  780.  
  781. if (already_forced(sym1)) {
  782.    if (sym2 != (Symbol)0) choose_representation(sym2);
  783.    return;
  784. }
  785.  
  786. n = tup_size(NOT_CHOSEN);
  787. for (i=1;i<=n; i+=2) {
  788.     if ((Symbol) NOT_CHOSEN[i]==sym1) {
  789.        tup = (Tuple) NOT_CHOSEN[i+1];
  790.        if (sym2 != (Symbol)0)  { 
  791.           NOT_CHOSEN[i+1] = (char *) tup_with(tup, (char *) sym2);
  792.        }
  793.        return;
  794.     }
  795. }
  796. NOT_CHOSEN = tup_exp(NOT_CHOSEN, (unsigned) n+2);
  797. NOT_CHOSEN[n+1] = (char *) sym1;
  798. if (sym2 == (Symbol)0)
  799.     NOT_CHOSEN[n+2] = (char *) tup_new(0);
  800. else
  801.     NOT_CHOSEN[n+2] = (char *) tup_new1((char *)sym2);
  802. return;
  803. }
  804. static void not_chosen_delete(Symbol sym)                /*;not_chosen_delete*/
  805. {
  806.     int     i,n;
  807.  
  808. n = tup_size(NOT_CHOSEN);
  809. for (i=1;i<=n; i+=2) {
  810.     if ((Symbol) NOT_CHOSEN[i]== sym) {
  811.        NOT_CHOSEN[i] = NOT_CHOSEN[n-1];
  812.        NOT_CHOSEN[i+1] = NOT_CHOSEN[n];
  813.        NOT_CHOSEN[0] = (char *) n-2;
  814.        return;
  815.     }
  816. }
  817. }
  818. default_size_value(Symbol type_name)            /*; default_size_value */
  819. /*
  820.  * Robert might want to add to this routine.
  821.  *
  822.  * If there were any errors in the compilation just return a default of 32
  823.  * rather than any more detailed calculation since the type might be
  824.  * an incorrect syntactic form (type 'any' or the like) or semantically
  825.  * incorrect. (i.e. using a floating point as the index type of an array)
  826.  */
  827. {
  828. int        size_v,num_of_comps;
  829. Fortup    ft1; 
  830. Tuple    bounds;
  831. Node    lo,hi;
  832. Symbol    i,component;
  833. Symbol    b_type, r_type, v_type, priv_decl;
  834. int        swap_private;
  835. Tuple    components;
  836. Symbol    field_name;
  837.  
  838. if (errors) {
  839.    return 32;
  840. }
  841. if (is_numeric_type(type_name)) {
  842.     size_v = 32;
  843. }
  844. else if (NATURE(root_type(type_name)) == na_enum) {
  845.   /*
  846.    * Some more elaborate code would be here to determine the # of bits
  847.    * depending on the # of enumeration values.
  848.    */
  849.    size_v = 8;
  850. }
  851. else if (is_array(type_name)) {
  852.    num_of_comps = 1;
  853.    FORTUP(i=(Symbol),index_types(type_name),ft1);
  854.       bounds = SIGNATURE(i);
  855.     /*
  856.      * The bounds are undefined in the case where one of the indices was
  857.      * some incorrect syntactic form (type 'any' or the like).
  858.      */
  859.  
  860.       if (bounds == (Tuple)0) {
  861.           return -1;
  862.       }
  863.  
  864.       lo = (Node) numeric_constraint_low(bounds);
  865.       hi = (Node) numeric_constraint_high(bounds);
  866.     /*
  867.      * The size of the array can be calculated now only if they are static
  868.      * and are integers. Static non-integer values can come about due to
  869.      * error conditions such as using a floating point type as the index.
  870.      * Non-static size is indicated with -1.
  871.      */
  872.  
  873.       if (!(is_static_expr(lo) && is_static_expr(hi))) {
  874.          return -1;
  875.       }
  876.       num_of_comps =  num_of_comps * 
  877.                       (INTV((Const)N_VAL(hi)) - INTV((Const)N_VAL(lo)) + 1);
  878.    ENDFORTUP(ft1);
  879.    component = component_type(type_name);
  880.    size_v = num_of_comps * default_size_value(component);
  881. }
  882. else if (is_record(type_name)) {
  883.    size_v = 0;
  884.    b_type = base_type(type_name);
  885.    swap_private = FALSE;
  886.    r_type = root_type(type_name);
  887. /*
  888.  * Check to see if either the base_type or the root_type is private and
  889.  * if it is swap the private decls with the visible part so that the record
  890.  * components can be made fully visible. We will swap them back at the end.
  891.  */
  892.    if (TYPE_OF(b_type) == symbol_private || 
  893.        TYPE_OF(b_type) == symbol_limited_private) {
  894.         swap_private = TRUE;
  895.    }
  896.    else if (TYPE_OF(r_type) == symbol_private || 
  897.                 TYPE_OF(r_type) == symbol_limited_private) {
  898.           b_type = r_type;
  899.           swap_private = TRUE;
  900.    }
  901.  
  902.    if (swap_private) {
  903.       v_type = private_decls_get((Private_declarations)
  904.                       private_decls(SCOPE_OF(b_type)), b_type);
  905.  
  906.       /*  Check for error condition and if so return standard size. */
  907.       if (v_type == (Symbol)0) {
  908.           return 32;
  909.       }
  910.       priv_decl = b_type ;
  911.       b_type = v_type ;
  912.    }
  913.  
  914.    components = build_comp_names((Node) invariant_part(b_type));
  915.    /* add in the disciminants to the invariant fields , but not the special
  916.     * constrained symbol
  917.     */
  918.    FORTUP(field_name=(Symbol),(Tuple) discriminant_list(b_type), ft1);
  919.       if (field_name != symbol_constrained) {
  920.         components = tup_with(components, (char *) field_name);
  921.       }
  922.    ENDFORTUP(ft1);
  923.  
  924. #ifdef TBSL
  925.    variant = variant_part(b_type);
  926.    /* Currently does not work with nested variants */
  927.    if (tup_size(variant) != 0) {
  928.       [-, variants] := variant;
  929.       for [-, decls] in variants loop
  930.          if decls /= ["null"] then
  931.             components +:= decls(1);
  932.          end if;
  933.       end loop;
  934.    }
  935. #endif 
  936.  
  937.    FORTUP(field_name=(Symbol),components, ft1);
  938.       size_v = size_v + component_size(TYPE_OF(field_name));
  939.    ENDFORTUP(ft1);
  940.       
  941.    if (swap_private)  {
  942.       b_type = priv_decl ;
  943.    }
  944. }
  945. else {
  946.    size_v = 32;
  947. }
  948. return size_v;
  949. }
  950.  
  951. component_size(Symbol type_name)            /*; component_size*/
  952.  
  953. /*
  954.  * Return the size of a component of a record or an array by first checking its
  955.  * representation. At this point since the type of the component should have 
  956.  * been forced already we just need to extract the size given in the 
  957.  * representation. This was derived by either an explicit rep clause specifying
  958.  * the size or computed based on some default formula. In the case where the 
  959.  * type was not forced yet a default size is calculated for it.
  960.  */
  961.  
  962. {
  963. if (REPR(type_name) != (Tuple)0) {
  964.    return (int) REPR(type_name)[size_position];
  965. }
  966. else {
  967.    /* Type was not forced yet. (Probably some error condition) */
  968.    return default_size_value(type_name);
  969. }
  970. }
  971.  
  972. static Tuple default_record_value(Symbol type_name)        /*;default_record_value */
  973. {
  974.     Symbol     b_type,r_type,v_type, field_name, priv_decl;
  975.     int        swap_private;
  976.     Tuple    attribute_list, tup2, tup4, field_names;
  977.     int        position, first_bit, field_size, current_offset;
  978.     int        record_size;
  979.     Fortup    ft1;
  980.  
  981.  
  982.        b_type = base_type(type_name);
  983.        swap_private = FALSE;
  984.        r_type = root_type(type_name);
  985.  
  986. /* 
  987.  * Check to see if either the base_type or the root_type is private and
  988.  * if it is swap the private decls with the visible part so that the record
  989.  * components can be made fully visible. We will swap them back at the end.
  990.  */
  991.    if (TYPE_OF(b_type) == symbol_private ||
  992.        TYPE_OF(b_type) == symbol_limited_private) {
  993.        swap_private = TRUE;
  994.    }
  995.    else if (TYPE_OF(r_type) == symbol_private ||
  996.             TYPE_OF(r_type) == symbol_limited_private) {
  997.           b_type = r_type;
  998.           swap_private = TRUE;
  999.    }
  1000.   if (swap_private) {
  1001.       v_type = private_decls_get((Private_declarations)
  1002.                       private_decls(SCOPE_OF(b_type)), b_type);
  1003.  
  1004.       priv_decl = b_type ;
  1005.       b_type = v_type ;
  1006.    }
  1007.  
  1008. current_offset = 0;
  1009. attribute_list = tup_new(0);
  1010. #ifdef TBSL
  1011. variant := ST(b_type).signature.variant_part;
  1012.  
  1013. -- Currently does not work with nested variants
  1014. if variant /= [] then
  1015.    [-, variants] := variant;
  1016.  
  1017.    for [-, decls] in variants loop
  1018.       if decls /= ["null"] then
  1019.          components +:= decls(1);
  1020.       end if;
  1021.    end loop;
  1022. end if;
  1023. #endif
  1024.  
  1025. field_names = build_comp_names((Node) invariant_part(b_type));
  1026. FORTUP(field_name=(Symbol),field_names, ft1);
  1027.    position = current_offset / storage_unit;
  1028.    first_bit = current_offset % storage_unit;
  1029.    field_size = component_size(TYPE_OF(field_name)) + padding;
  1030.    current_offset = current_offset + field_size + padding;
  1031.    tup4 = tup_new(4);
  1032.    tup4[1] = (char *) field_name;
  1033.    tup4[2] = (char *) position;
  1034.    tup4[3] = (char *) first_bit;
  1035.    tup4[4] = (char *) (first_bit + field_size -1);
  1036.    attribute_list = tup_with (attribute_list, (char *) tup4);
  1037. ENDFORTUP(ft1);
  1038.        
  1039. /* Ignore record size for now */
  1040. record_size = current_offset + padding;
  1041.  
  1042. if (swap_private) {
  1043.    b_type = priv_decl ;
  1044. }
  1045. tup2 = tup_new(2); 
  1046. tup2[1] = (char *) 0;
  1047. tup2[2] = (char *) attribute_list;
  1048. return tup2;
  1049. } 
  1050.  
  1051. Node size_attribute(Node expn)                         /*;size_attribute*/
  1052. {
  1053. Symbol    typ1, v_type,b_type;
  1054. Tuple    current_rep;
  1055. Node    typ_node;
  1056. int        size_value;
  1057.  
  1058. typ_node = N_AST2(expn);
  1059. if (N_KIND(typ_node) != as_simple_name) {
  1060.     typ1 = N_TYPE(typ_node);
  1061. }
  1062. else {
  1063.     typ1 = N_UNQ(typ_node);
  1064. }     
  1065. if (!is_type(typ1)) {
  1066.    typ1 = TYPE_OF(typ1);
  1067. }
  1068. if (!is_static_subtype(typ1)) {
  1069.    return expn;
  1070. }
  1071. if (is_generic_type(typ1)) {
  1072.    return expn;
  1073. }
  1074. if (TYPE_OF(typ1) == symbol_private ||   
  1075.     TYPE_OF(typ1) == symbol_limited_private) {
  1076.     v_type = private_decls_get((Private_declarations)
  1077.                                   private_decls(SCOPE_OF(typ1)), typ1);
  1078.     /*
  1079.      * Check to seem if vis_decl is defined before accessing it. It might be
  1080.      * undefined in the case of compilation errors.
  1081.      */
  1082.      if (v_type != (Symbol)0) {
  1083.          typ1 = TYPE_OF(v_type);     /* TYPE_OF field in the symbol table */
  1084.      }
  1085. }
  1086. if (is_scalar_type(typ1)) {
  1087.    b_type = base_type(typ1);
  1088.    force_representation(b_type);
  1089.    current_rep = RCINFO(b_type);
  1090.    if ((int) current_rep[size_position] == rc_unset) {
  1091.       size_value = default_size_value(b_type);
  1092.    }
  1093.    else {
  1094.       size_value = (int) current_rep[size_position+1];
  1095.    }
  1096.    return new_ivalue_node(uint_const(int_fri(size_value)), symbol_integer);
  1097. }
  1098. else {
  1099.    return expn;
  1100. }
  1101. }
  1102. #ifdef ERRORS
  1103. #endif
  1104.